Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/calc1a/calc1.bas

BASIC Source File | 1995-05-09 | 7KB | 346 lines

' Copyright 1994 C Big Dog Software.  All rights reserved
' Use in your own products permitted as long as a valid
' copyright notice is displayed during program initialization
' along with the following:
'       Portions of this program are Copyright C Big Dog Software
'
Option Explicit
Const mt$ = ""
Const zero% = 0
Const one% = 1
Const two% = 2
Const plus$ = "+"
Const minus$ = "-"
Const times$ = "*"
Const div$ = "/"
Const oparen$ = "("
Const cparen$ = ")"
Const raise$ = "^"
Const UNARY$ = "U"
Dim tokens$(1 To 7)      ' token symbols
Dim tprec%(1 To 7)       ' token precedence (higher is more important)
Dim vstack$(1 To 100)    ' value manipulation
Dim ostack$(1 To 100)    ' operand
Dim vtos%   ' stack pointer of value stack
Dim otos%   ' stack pointer of operand stack
Dim tstr$
Dim calcerr$
Dim pcount% ' paren reduction
Dim lastok%
Const OPERATOR% = 1
Const NUMERIC% = 2

Sub clearstacks ()
Dim i%
For i = LBound(ostack) To UBound(ostack)
    ostack(i) = mt
Next
For i = LBound(vstack) To UBound(vstack)
    vstack(i) = mt
Next
initcalc
End Sub

Function eval$ (parseme$)
Dim tok$, orig$, otop$
orig = parseme
lastok = OPERATOR
clearstacks
calcerr = mt
pcount = zero
tok = lexx(parseme)
While tok <> mt
    Select Case tok
    Case oparen
        opush tok
    Case cparen
        opush tok
    Case raise
        opush tok
    Case times
        opush tok
    Case div
        opush tok
    Case plus
        opush tok
    Case minus
        If lastok = OPERATOR Then
        opush UNARY
        Else
        opush tok
        End If
    Case Else
        If IsNumeric(tok) Then
        vpush tok
        Else
        eval = "ERROR: Unrecognized token :" + parseme + ":"
        Exit Function
        End If
    End Select
    tok = lexx(parseme)
    If calcerr <> mt Then
    eval = calcerr
    Exit Function
    End If
Wend
reduce
If calcerr <> mt Then
    eval = calcerr
ElseIf vtos <> one Or otos <> zero Then
    If otos <> zero Then
    calcerr = opop()
    If calcerr = oparen Then
        eval = "Mismatched Left Parenthesis ("
    Else
        eval = "Unable to reduce expression due to extra " + calcerr
    End If
    Else
    eval = "Unable to reduce expression"
    End If
Else
' at this point, the top of stack should contain the value
    eval = vpop()
End If
End Function

Function getprec% (tokval$)
' get token precedence
Dim i%
If tokval = "U" Then
    getprec = 10
    Exit Function
End If
For i = one To UBound(tokens)
    If tokens(i) = tokval Then
    getprec = tprec(i)
    Exit Function
    End If
Next
getprec = 0
End Function

Sub initcalc ()
vtos = 0
otos = 0
tokens(1) = "("
tprec(1) = 3
tokens(2) = ")"
tprec(2) = 3
tokens(3) = "*"
tprec(3) = 2
tokens(4) = "/"
tprec(4) = 2
tokens(5) = "+"
tprec(5) = 1
tokens(6) = "-"
tprec(6) = 1
tokens(7) = "^"
tprec(7) = 4
tstr = "()*/+-^"
End Sub

Function lexx$ (parsexpr$)
Dim i%, w%, j%, cc$, pl%, hs%, wc$, ft$
hs = Len(parsexpr)
If parsexpr = mt Then
    lexx = mt
    Exit Function
End If
hs = Len(parsexpr)
ft = mt           ' find the FIRST token
For i = one To hs
    cc = Mid$(parsexpr, i, one)
    j = InStr(tstr, cc)
    If j Then
    ft = cc
    Exit For
    End If
Next
If ft <> mt Then
    w = InStr(parsexpr, ft)
    If w Then
    If w = one Then
        lexx = Left$(parsexpr, one)
        parsexpr = Trim$(Mid$(parsexpr, two))
    Else
        lexx = Trim$(Left$(parsexpr, w - one))
        parsexpr = Trim$(Mid$(parsexpr, w))
    End If
    Exit Function
    End If
End If
If IsNumeric(Trim$(parsexpr)) Then
    lexx = Trim$(parsexpr)
    parsexpr = mt
Else
    lexx = mt
    calcerr = "Unrecognized token at start of :" + parsexpr
End If
End Function

Function opop$ ()
If otos >= one Then
    opop = ostack(otos)
    ostack(otos) = mt
    otos = otos - one
Else
    opop = mt
End If
End Function

Sub opush (pval$)
Dim p1%, p2%
If pval = mt Then Exit Sub
If otos < UBound(ostack) Then
    If otos > zero Then
    If getprec(ostack(otos)) >= getprec(pval) And ostack(otos) <> oparen Then reduce
    End If
    lastok = OPERATOR
    otos = otos + one
    ostack(otos) = pval
    If pval = cparen Then reduce
Else
    calcerr = "Operand Stack blown."
End If
End Sub

Sub reduce ()
Dim v1$, v2$, o1$, lt%
o1 = opop()
Select Case o1
    Case mt
    If pcount Then
        calcerr = "Mismatched Right Parenthesis )"
        clearstacks
    End If
    Exit Sub
    Case oparen
    If pcount = zero Then
        lt = lastok
        opush o1
        lastok = lt
        Exit Sub
    End If
    pcount = pcount - one
    If pcount = zero Then Exit Sub
    If pcount < zero Then
        calcerr = "Mismatched Parenthesis"
        clearstacks
    End If
    Case cparen
    pcount = pcount + one
    Case UNARY
    lt = lastok
    vpush "-" + vpop()
    lastok = lt
    Case raise
    v1 = vpop()
    v2 = vpop()
    If v1 = mt Or v2 = mt Then
        calcerr = "Expression error near operand ^"
        clearstacks
        Exit Sub
    End If
    On Error Resume Next
    lt = lastok
    vpush Trim$(Str$(Val(v2) ^ Val(v1)))
    lastok = lt
    If Err Then
        calcerr = "Arithmetic Overflow"
        clearstacks
        Exit Sub
    End If
    On Error GoTo 0

    Case times
    v1 = vpop()
    v2 = vpop()
    If v1 = mt Or v2 = mt Then
        calcerr = "Expression error near operand *"
        clearstacks
        Exit Sub
    End If
    On Error Resume Next
    lt = lastok
    vpush Trim$(Str$(Val(v1) * Val(v2)))
    lastok = lt
    If Err Then
        calcerr = "Arithmetic Overflow"
        clearstacks
        Exit Sub
    End If
    On Error GoTo 0

    Case div
    v1 = vpop()
    v2 = vpop()
    If v1 = mt Or v2 = mt Then
        calcerr = "Expression error near operand /"
        clearstacks
        Exit Sub
    End If
    If Val(v1) = zero Then
        calcerr = "Division by zero"
        clearstacks
        Exit Sub
    End If
    On Error Resume Next
    lt = lastok
    vpush Trim$(Str$(Val(v2) / Val(v1)))
    lastok = lt
    If Err Then
        calcerr = "Arithmetic Overflow"
        clearstacks
        Exit Sub
    End If
    On Error GoTo 0

    Case plus
    v1 = vpop()
    v2 = vpop()
    If v1 = mt Or v2 = mt Then
        calcerr = "Expression error near operand +"
        clearstacks
        Exit Sub
    End If
    lt = lastok
    vpush Trim$(Str$(Val(v2) + Val(v1)))
    lastok = lt

    Case minus
    v1 = vpop()
    v2 = vpop()
    If v1 = mt Or v2 = mt Then
        calcerr = "Expression error near operand -"
        clearstacks
        Exit Sub
    End If
    lt = lastok
    vpush Trim$(Str$(Val(v2) - Val(v1)))
    lastok = lt
End Select
reduce
End Sub

Function vpop$ ()
If vtos >= one Then
    vpop = vstack(vtos)
    vstack(vtos) = mt
    vtos = vtos - one
Else
    vpop = mt
End If
End Function

Sub vpush (pval$)
If pval = mt Then Exit Sub
If vtos < UBound(vstack) Then
    lastok = NUMERIC
    vtos = vtos + one
    vstack(vtos) = pval
Else
    calcerr = "Value Stack blown."
End If
End Sub